home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ShareWare OnLine 2
/
ShareWare OnLine Volume 2 (CMS Software)(1993).iso
/
infor
/
feb93.zip
/
TIP845.LSP
< prev
next >
Wrap
Text File
|
1993-01-14
|
1KB
|
42 lines
;TIP845: RECT.LSP (C)1993, VICTOR V. JENSEN
; RECT.LSP - rectangle drawing program for Releases 10 & 11.
; by Victor V. Jensen, April, 1992.
(defun recerr (S / A)
(if (/= S "Function cancelled") (princ (strcat "\nError: " S)))
(command ".UCS" "P")
(foreach A s#v (setvar (car A) (cadr A)))
(setq *error* olderr s#v nil olderr nil)
(princ)
); end defun recerr
(defun C:RECT (/ A PT P1 P2 P3)
(setvar "CMDECHO" 0)
(setq A '("AXISMODE" "UCSICON" "UCSFOLLOW" "GRIDMODE" "ORTHOMODE" "COORDS")
olderr *error* *error* recerr
s#v (mapcar '(lambda (PT) (list PT (getvar PT))) A)
); setq
(foreach A s#v
(if (= (car A) "COORDS") (setvar (car A) 1) (setvar (car A) 0))
); foreach
(initget 1)
(setq PT (getpoint"\nFirst corner: "))
(command ".UCS" "O" PT)
(setq PT (list 0.0 0.0 0.0))
(initget 1)
(setq P2 (getcorner PT "\nOpposite corner: ")
P1 (list (car P2) (cadr PT) (caddr PT))
P3 (list (car PT) (cadr P2) (caddr P2))
); setq
(command ".PLINE" PT "W" "0" "" P1 P2 P3 "C")
(setq P1 (getangle PT "\nRotation angle or RETURN for none: "))
(if (= P1 nil) (setq P1 0))
(command ".ROTATE" PT "" PT (angtos P1) ".UCS" "P")
(foreach A s#v (setvar (car A) (cadr A)))
(setq *error* olderr s#v nil olderr nil)
(princ)
); end defun c:rect
(princ)
(C:RECT)